;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This program is free software.  You may run, copy, modify, and
;;; redistribute it under the terms of the GNU General Purpose License
;;; (GPL) version 3, or any later version.

(define-module (derivative parse context-free)
  #:use-module ((srfi srfi-1) #:select (fold-right reduce-right partition))
  #:use-module (srfi srfi-9)		;records
  #:use-module (srfi srfi-41)		;streams
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:autoload (ice-9 pretty-print) (truncated-print)
  #:use-module ((derivative language context-free)
		#:hide (δ D derivative)) ;redefined in this module
  #:use-module (derivative utils memoize)
  #:use-module (derivative utils fix)
  #:use-module (derivative utils sets)
  #:re-export (alt <alt>
	       cat <cat>
	       rep <rep>)
  #:export (<token> token? token
	    <red> red? red → -->
	    <eps*> eps*? eps* ε↓

	    <δ> δ
	    D derivative

	    parse parse/debug

	    ;; Useful parsers
	    any any* any+
	    one-of none-of
	    range
	    string

	    ;; Combinators
	    count at-least at-most bound
	    maybe many many+
	    trim-left trim-right trim
	    middle delimit

	    ;; Parsers for standard character sets
	    lower-case lower-case* lower-case+
	    upper-case upper-case* upper-case+
	    title-case title-case* title-case+
	    letter letter* letter+
	    digit digit* digit+
	    letter+digit letter+digit* letter+digit+
	    graphic graphic* graphic+
	    printing printing* printing+
	    whitespace whitespace* whitespace+
	    blank blank* blank+
	    iso-control iso-control* iso-control+
	    punctuation punctuation* punctuation+
	    symbol symbol* symbol+
	    hex-digit hex-digit* hex-digit+
	    ascii ascii* ascii+

	    ;; Examples/tests:
	    pcre->parser
	    parens-lang
	    numeral-parser
	    term-parser
	    scheme-parser))

(define-record-type <token>
  (token pred description)
  token?
  (pred token-pred)
  (description token-description))

;;; TODO: Would like this syntax so that you could specify a token
;;; predicate with minimal syntax and without having to use (srfi
;;; srfi-26)'s "cut".
;;;
;; (define-syntax token
;;   (syntax-rules (<>)
;;     ((_ body) (make-token (λ )))))

;;; Reduction by function f:X→Y maps trees from X into trees from Y.
(define-record-type <red>
  (make-red lang proc)
  red?
  (lang red-lang)
  (proc red-proc))

(define-syntax red
  (syntax-rules ()
    ((_ L proc) (make-red (delay L) proc))))
;; (define-syntax → red)
;; (define-syntax --> red)

(define-record-type <δ>			;nullability combinator
  (make-delta lang)
  nullability?
  (lang delta-lang))

(define-syntax δ
  (syntax-rules ()
    ((_ L) (make-delta (delay L)))))

;;; The null reduction partial parser, ε↓S, can only parse the null
;;; string; it returns a set of parse trees stored within.
(define-record-type <eps*>
  (make-eps* trees)
  eps*?
  (trees eps*-trees))
(define ε↓ make-eps*)

(define-syntax eps*
  (syntax-rules ()
    ((_) (make-eps* (set)))
    ((_ T* ...) (make-eps* (set T* ...)))))

(define nullable?
  (fix* #f
	(match-lambda
	  ;; "Check whether this parser can parse null."
	  ((or ($ <eps*> _) 'eps) #t)
	  (($ <rep> _) #t)
	  (($ <alt> p p')
	   (or (nullable? (force p)) (nullable? (force p'))))
	  (($ <cat> p p')
	   (and (nullable? (force p)) (nullable? (force p'))))
	  (($ <red> p _) (nullable? (force p)))
	  (else #f))))

(define D
  (memoize
   (lambda (c language)
     (match language
       ('empty 'empty)
       ((or ($ <eps*> _) 'eps) 'empty)
       (($ <δ> _) 'empty)
       ((? char? a)                     ;implicit promotion to <token>
        (if (eq? a c) (eps* a) 'empty))
       (($ <token> pred _)
        (if (pred c) (eps* c) 'empty))

       (($ <alt> L L')
	(alt (D c (force L)) (D c (force L'))))
       (($ <cat> (= force (? nullable? L)) L') ;early compaction!
       	(alt (cat (D c L) (force L'))
       	     (cat (make-eps* (parse-null L)) (D c (force L')))))
       (($ <cat> L L')
       	(cat (D c (force L)) (force L')))
       (($ <rep> (= force L))
	(cat (D c L) language))
       (($ <red> L f)
        (red (D c (force L)) f))

       (x
        (if (equal? c x) (eps* c) 'empty))))))
(define derivative D)

(define* (parse w p #:key debug?)
  "Returns a list of parse trees of W for parser P.  W may be either a
string, an (srfi srfi-41) lazy stream of characters, or an input
port."
  (when debug?
    (format #t "language size: ~d~%" (language-size p)))
  (match w
    ((or ()
	 (? string? (? string-null?)) 
	 (? stream-null?)
	 (? port? (= peek-char (? eof-object?))))
     (match (set->list (parse-null p))
       (()
	;; All input consumed, but parser needs more for a null parse.
	(format (current-error-port) "error: unexpected end-of-input~%")
        (print-expected p (current-error-port))
	'())
       (x x)))
    ((or (head tail ...)
	 (? string? (= (λ (s) (string-ref s 0)) head) (= (λ (s) (substring s 1)) tail))
	 (? stream? (= stream-car head) (= stream-cdr tail))
	 (? port? (= read-char head) tail))
     (match (compact (D head p))
       ('empty
        (format (current-error-port) "error: parser collapsed at input `~a'~%" head)
        (print-expected p (current-error-port))
        '())
       (D' (parse tail D' #:debug? debug?))))))

(define (parse/debug w p)
  (parse w p #:debug? #t))

(define* (print-expected p #:optional (port (current-output-port)))
  (define ->string
    (match-lambda
      ('eps "end-of-input")
      ((? char? c) (format #f "`~c'" c))
      ((? procedure? p) (format #f "char satisfying predicate ~a" p))
      ((? char-set? cs) (format #f "char in ~a"
				(with-output-to-string
				  (lambda ()
				    (truncated-print cs #:width 30)))))
      (else else)))
  (define print-list
    (match-lambda
      (() (format port "end-of-input~%"))
      ((e)
       (format port "~a~%" (->string e)))
      ((e e')
       (format port "~a or ~a~%" (->string e) (->string e')))
      ((e e' ...)
       (format port "~a" (->string e))
       (let loop ((r e'))
         (match r
           ((e)
            (format port ", or ~a~%" (->string e)))
           ((e e' ...)
            (format port ", ~a" (->string e))
            (loop e')))))))

  (format port "error: expecting ")
  (print-list (set->list (parse-expected p))))

(define (string-parser? p)
  (define string-characters
    (fix* #f
          (match-lambda
            ;; Return a list of the characters, or #f
            ((or ($ <cat> (= force (? char? c)) (= force 'eps))
		 ($ <red> (= force (? char? c)) (? (λ (p) (eq? p list)))))
             (list c))
            (($ <cat> (= force (? char? c)) (= force (? char? c')))
             (list c c'))
            (($ <cat> (= force (? char? c)) (= force (= string-characters s)))
             (and s (cons c s)))
            ((or ($ <red> p _) ($ <rep> p))
             (string-characters (force p)))
            (else #f))))
  (and=> (string-characters p)
         list->string))

(define parse-expected
  (fix* (set)
        (match-lambda
          ('empty (set))
          ((or 'eps ($ <eps*> _)) (set))
          ((? char? c) (set c))
          (($ <token> pred desc) (set desc))
          ((or ($ <alt> (= force p) (= force p'))
               ($ <cat> (= force (? nullable? p)) (= force p')))
           (set-union (parse-expected p)
                      (parse-expected p')))
          ((and C ($ <cat> p _))
           (or (and=> (string-parser? C)
                      (λ (s) (set (format #f "~s" s))))
               (parse-expected (force p))))
          (($ <rep> p)
           (parse-expected (force p)))
          (($ <red> p _)
           (parse-expected (force p)))
	  (x (set x)))))

(define parse-null
  (memoize
   (fix* (set)
	 (match-lambda
	   ('empty (set))
	   ('eps (set '()))
	   (($ <eps*> T) T)
	   (($ <δ> p) (parse-null (force p)))
	   ((? char?) (set))
           (($ <token> _ _) (set))
	   (($ <alt> p p') (set-union (parse-null (force p))
				      (parse-null (force p'))))
	   (($ <cat> p p')
	    ;; leaking implementation details here...
	    (let ((set-vhash (@@ (derivative utils sets) set-vhash))
		  (T  (parse-null (force p)))
		  (T' (parse-null (force p'))))
	      ;; This is Racket's for*/set procedure:
	      (vlist-fold (match-lambda*
			    (((t . _) result)
			     (vlist-fold (match-lambda*
					   (((t' . _) result')
					    (set-insert (cons t t')
							result')))
					 result
					 (set-vhash T'))))
			  (set)
			  (set-vhash T))))
	   (($ <red> p f) (set-map f (parse-null (force p))))
	   (($ <rep> _) (set '()))))))

(define empty?
  (fix* #f
	(match-lambda
	  ;; "Check whether this is the empty parser."
	  ('empty #t)
	  (($ <alt> p p') (and (empty? (force p)) (empty? (force p'))))
	  (($ <cat> p p') (or (empty? (force p)) (empty? (force p'))))
          (($ <red> p _) (empty? (force p)))
	  (else #f))))

(define null?
  (fix* #t
	(match-lambda
	  ;; "Check whether this parser is the null parser."
	  ((or ($ <eps*> _) 'eps) #t)
	  (($ <alt> p p') (and (null? (force p)) (null? (force p'))))
	  (($ <cat> p p') (and (null? (force p)) (null? (force p'))))
	  (($ <red> p _) (null? (force p)))
	  (else #f))))

(define compact
  (memoize
   (match-lambda
     ;; reduction rules
     ((? empty? p) 'empty)
     ((? null? p) (make-eps* (parse-null p)))
     (($ <alt> (= force (? empty?)) p) (compact (force p)))
     (($ <alt> p (= force (? empty?))) (compact (force p)))
     (($ <cat> (= force
                  (and (? null?)
		     (= parse-null
			(= set->list (t)))))
	       (= force p'))
      (red (compact p')
	   (λ (t') (cons t t'))))
     (($ <cat> (= force p)
	       (= force
                  (and (? null?)
		     (= parse-null
			(= set->list (t'))))))
      (red (compact p)
	   (match t'
	     (() list)
	     (else (λ (t) (cons t t'))))))
     (($ <red> (= force (? empty?)) _) 'empty)
     (($ <red> (= force ($ <red> p f)) g)
      (red (compact (force p)) (compose g f)))
     (($ <red> p f) (red (compact (force p)) f))
     ;; recursion rules
     (($ <alt> p p') (alt (compact (force p)) (compact (force p'))))
     (($ <cat> p p') (cat (compact (force p)) (compact (force p'))))
     (else else))))

;;; Visualization/exploration:

(define language-size
  (graph-search
   (match-lambda
     ((or ($ <cat> L L') ($ <alt> L L'))
      (+ 1 (language-size (force L))
	   (language-size (force L'))))
     ((or ($ <red> L _) ($ <rep> L) ($ <δ> L))
      (+ 1 (language-size (force L))))
     (else 1))
   (const 0)))

(define* (dotify parser #:optional (port (current-output-port)))
  "Output a grammer/parser as a graphviz dot file."
  (define id
    (memoize
     (let ((counter 0))
       (lambda _
	 (set! counter (1+ counter))
	 counter))))
  
  (define dotify-nodes
    (graph-search
     (lambda (p)
       (match p
	 ('empty
	  (format port "\"~s\" [label = \"empty\"];~%" (id p)))
	 ('eps
	  (format port "\"~s\" [label = \"eps\"];~%" (id p)))
	 (($ <eps*> T)
	  (format port "\"~s\" [shape = \"record\", label = \"eps* | ~{~a~^, ~}\"];~%" (id p) (set->list T)))
	 ((? char?)
	  (format port "\"~s\" [shape = \"record\", label = \"#\\\\~c\"];~%" (id p) p))
         (($ <token> _ desc)
          (format port "\"~s\" [shape = \"record\", label = \"~s\"];~%" (id p) desc))
	 (($ <alt> (= force L) (= force L'))
	  (format port "\"~s\" [label = \"or\"];~%" (id p))
	  (dotify-nodes L)
	  (dotify-nodes L')
	  (format port "\"~s\" -> \"~s\" [];~%" (id p) (id L))
	  (format port "\"~s\" -> \"~s\" [];~%" (id p) (id L')))
	 (($ <cat> (= force L) (= force L'))
	  (format port "\"~s\" [shape=\"none\", margin=0, label = ~
                        <<table border=\"0\" cellborder=\"1\" cellspacing=\"0\" cellpadding=\"4\">~
                          <tr>~
                            <td colspan=\"2\">cat</td>~
                          </tr>~
                          <tr>~
                            <td port=\"L\">L</td>~
                            <td port=\"R\">R</td>~
                          </tr>~
                        </table>>];~%" (id p))
	  (dotify-nodes L)
	  (dotify-nodes L')
	  (format port "\"~s\":L -> \"~s\" [];~%" (id p) (id L))
	  (format port "\"~s\":R -> \"~s\" [];~%" (id p) (id L')))
	 (($ <red> (= force L) _)
	  (format port "\"~s\" [label = \"red\"];~%" (id p))
	  (dotify-nodes L)
	  (format port "\"~s\" -> \"~s\" [];~%" (id p) (id L)))
	 (($ <δ> (= force L))
	  (format port "\"~s\" [label = \"delta\"];~%" (id p))
	  (dotify-nodes L)
	  (format port "\"~s\" -> \"~s\" [];~%" (id p) (id L)))))))

  (format port "digraph {~%node[];~%")
  (dotify-nodes parser)
  (format port "\"~s\" [shape = \"doublecircle\"];~%" (id parser))
  (format port "}~%"))


;;; Useful standard parsers
(define any (token (λ (c) (char? c)) "any char"))
(define any* (rep any))
(define any+ (cat any (rep any)))

(define* (one-of S #:optional description)
  ;; Return a token that accepts any of the characters in S, which may
  ;; be a list of characters, a string, or a character set.
  (match S
    ((lst ...)
     (token (λ (c) (memq c lst))
	    (or description S)))
    ((? string?)
     (token (λ (c) (string-index S c))
	    (or description
		(format #f "char in \"~a\"" S))))
    ((? char-set?)
     (token (λ (c) (char-set-contains? S c))
	    (or description S)))))
(define* (none-of S #:optional description)
  (match (one-of S description)
    (($ <token> pred desc)
     (token (negate pred)
            (or description
                (match desc
                  ((lst ...)
                   (format #f "char not in ~a" lst))
                  ((? string? str)
                   (format #f "char not in ~s" str))
		  ((? char-set? cs)
		   (format #f "char not in ~a"
			   (with-output-to-string
			     (lambda ()
			       (truncated-print cs #:width 30)))))))))))
(define (range c c')
  (let ((i (char->integer c))
	(i' (char->integer c')))
    (token (λ (c) (and (>= (char->integer c) i)
		       (<= (char->integer c) i')))
	   (format #f "char in ~a..~a" c c'))))
(define (string str)
  "Returns a parser that matches exactly STR and returns STR."
  (red (fold-right (λ (c r) (cat c r))
		   'eps
		   (string->list str))
       list->string))


;;; Useful combinators
(define (middle left parser right)
  "Return a parser that parses LEFT, PARSER, then RIGHT and returns
only the result of PARSER's parse."
  (red (cat left parser right)
       (match-lambda ((_ x . _) x))))

(define (count n p)
  "Returns a parser that matches parser P axactly N times."
  (let loop ((n n)
	     (result 'eps))
    (if (zero? n)
	result
	(loop (1- n) (cat p result)))))

(define (at-least n p)
  "Returns a parser that matches parser P at least N times."
  (red (cat (count n p)
	    (rep p))
       (match-lambda
	 ((x y ...) (append x y)))))

(define (at-most n p)
  "Returns a parser that matches parser P at most N times."
  (let loop ((n n)
	     (result 'eps))
    (if (zero? n)
	result
	(loop (1- n) (maybe (cat p result))))))

(define (bound n m p)
  "Returns a parser that matches parser P at least N times, and at
most M times."
  (red (cat (count n p)
	    (at-most (- m n) p))
       (match-lambda
	 ((x y ...) (append x y)))))

(define (many p) (rep p))

(define (many+ p) (cat p (rep p)))

(define (maybe p)
  "Return a parser that might parse P, or might not, in which case the
empty list is produced."
  (alt p 'eps))

(define (trim-right p)
  "Return a parser that discards any horizontal whitespace following P."
  (red (cat p blank*)
       (match-lambda ((r . _) r))))

(define (trim-left p)
  "Return a parser that discards any horizontal whitespace preceding P."
  (red (cat blank* p)
       (match-lambda ((_ . r) r))))

(define (trim p)
  "Return a parse that discards any horizontaol whitespace on either
side of P."
  (red (cat blank* p blank*)
       (match-lambda ((_ r . _) r))))

(define (delimit delim . lst)
  "Return a parser that applies each parser in LST delimited by the
parser DELIM.  This parser discards the delimeter results and returns
the rest as a list."
  (match lst
    ((p)
     (cat p (rep (red (cat delim p)
		      cdr))))
    (else (reduce-right (λ (p r)
			  (red (cat p delim r)
			       (match-lambda ((x _ . y) (cons x y)))))
			'eps lst))))


;;; Parsers for standard character sets
(define lower-case (one-of char-set:lower-case "lower-case char"))
(define lower-case* (many lower-case))
(define lower-case+ (many+ lower-case))
(define upper-case (one-of char-set:upper-case "upper-case char"))
(define upper-case* (many upper-case))
(define upper-case+ (many+ upper-case))
(define title-case (one-of char-set:title-case "title-case char"))
(define title-case* (many title-case))
(define title-case+ (many+ title-case))
(define letter (one-of char-set:letter "letter"))
(define letter* (many letter))
(define letter+ (many+ letter))
(define digit (one-of char-set:digit "digit"))
(define digit* (many digit))
(define digit+ (many+ digit))
(define letter+digit (one-of char-set:letter+digit "letter or digit"))
(define letter+digit* (many letter+digit))
(define letter+digit+ (many+ letter+digit))
(define graphic (one-of char-set:graphic "graphic char"))
(define graphic* (many graphic))
(define graphic+ (many+ graphic))
(define printing (one-of char-set:printing "printing char"))
(define printing* (many printing))
(define printing+ (many+ printing))
(define whitespace (one-of char-set:whitespace "whitespace"))
(define whitespace* (many whitespace))
(define whitespace+ (many+ whitespace))
(define blank (one-of char-set:blank "blank"))
(define blank* (many blank))
(define blank+ (many+ blank))
(define iso-control (one-of char-set:iso-control "iso-control char"))
(define iso-control* (many iso-control))
(define iso-control+ (many+ iso-control))
(define punctuation (one-of char-set:punctuation "punctuation"))
(define punctuation* (many punctuation))
(define punctuation+ (many+ punctuation))
(define symbol (one-of char-set:symbol "symbol char"))
(define symbol* (many symbol))
(define symbol+ (many+ symbol))
(define hex-digit (one-of char-set:hex-digit "hex digit"))
(define hex-digit* (many hex-digit))
(define hex-digit+ (many+ hex-digit))
(define ascii (one-of char-set:ascii "ascii char"))
(define ascii* (many ascii))
(define ascii+ (many+ ascii))


(define (pcre->parser pcre)
  "Return a parser for the perl-compatible regular expression PCRE.
Supports a subset of PCRE.  Notably, negative character sets, posix
named character sets, escaped characters, anchors, and groups are not
supported.  The rest may be incomplete, experimental, ambiguous, and
slow.

  E.g.:
    (pcre->parser \"foo[abc]{3,}\")
    => $1 = #<<cat> left: #<promise #\f>…>
    (parse \"foobaca\" $1)
    => $2 = ((#\\f #\\o #\\o (#\\b #\\a #\\c #\\a)))
    (parse \"\" (pcre->parser \"...[f-h][o-qs-uxz][0-9]\"))
    => TODO: AMBIGUOUS!!! "
  (define literal
    (none-of "[.{}"))
  (define character-class-literal
    (alt (red (cat any #\- any)
	      (match-lambda
		((l _ . u) (range l u))))
	 (none-of "-]")))
  (define character-class
    ;; TODO: extend with negative classes and posix named classes
    (red (middle #\[ (many+ character-class-literal) #\])
	 (match-lambda
	   ((c) c)
	   ((l ...)
	    ;; This might be overkill, but it minimizes the size of
	    ;; the generated language:
	    (call-with-values (lambda () (partition token? l))
	      (match-lambda*
		((() (cs ...))
		 (one-of cs))
		(((and tl (t _ ...)) (cs ...))
		 (let ((tp (reduce-right (λ (p r) (alt p r)) t tl)))
		   (match cs
		     (() tp)
		     ((c) (alt tp c))
		     ((cs ...) (alt tp (one-of cs))))))))))))
  (define atom
    (alt literal
	 character-class
	 (red #\. (const any))))
  (define element
    (red (cat atom (alt #\? #\+ #\*
			(cat #\{ numeral-parser #\}) ;exactly n
			(cat #\{ numeral-parser #\, #\}) ;n or more
			(cat #\( numeral-parser #\, numeral-parser #\})
			'eps))
	 (match-lambda
	   ((a) a)
	   ((a . #\?) (maybe a))
	   ((a . #\+) (many+ a))
	   ((a . #\*) (many a))
	   ((a _ n _ m . _) (bound n m a))
	   ((a _ n _ . _) (at-least n a))
	   ((a _ n . _) (count n a)))))
  (define expr
    (red (alt (cat element expr)
	      'eps)
	 (match-lambda
	   (() 'eps)
	   ((e) e)
	   ((e . e') (cat e e')))))
  (define parse-alt
    (red (alt (cat expr #\| parse-alt)
	      expr)
	 (match-lambda
	   ((e _ . e') (alt e e'))
	   (x x))))
  (match (parse/debug pcre parse-alt)
    ((p) p)))

;;; Some examples:

(define parens-lang
  ;; Parse strings of the form "()", "()()", "((()())())".
  (alt (cat parens-lang parens-lang)
       (cat #\( parens-lang #\))
       (eps* '())))

(define numeral-parser
  (red (rep digit)
       (compose string->number list->string)))
(define arithmetic-parser
  (alt (cat term-parser #\* arithmetic-parser)
       term-parser))
(define term-parser
  (alt (red (cat numeral-parser (alt #\+ #\-) term-parser)
	    (match-lambda ((head #\+ . tail)
			   (+ head tail))
			  ((head #\- . tail)
			   (- head tail))))
       numeral-parser))

(define scheme-parser
  (let ((scheme-symbol (red (rep (one-of (char-set-difference char-set:graphic
							      (char-set #\( #\)))
					 "graphic non-paren char"))
			    (compose string->symbol list->string))))
    (alt (red (middle #\( (delimit whitespace+ scheme-parser) #\))
	      append)
	 scheme-symbol)))
